home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
system
/
ipca12a.zip
/
IPCA.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-10-10
|
6KB
|
202 lines
{$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
{$M 8192,0,0}
program ipca;
(***********************************************************************
NOTICE
======
This program and every file distributed with it are copyright (C)
by the authors, who retain authorship both of the pre-compiled and
compiled codes. Their use and distribution are unrestricted, as long
as nobody gets any richer in the process. Although these programs
were developed to the best of the authors abilities, no guarantees
can be given as to their performance. By using them, the user
accepts all risks and the authors decline all liability.
************************************************************************)
uses crt;
type
arrbyte = array [1..16] of byte;
var
ipcarr : arrbyte absolute $0000:$04F0;
str1, str2, str3 : string;
procedure wrtln(s: string);
begin
writeln(s);
end;
procedure error(e: byte);
var
ch : char;
begin
clrscr;
wrtln('╔═════════════════════════════════════════════════════════════════════════════╗');
wrtln('║ Program IPCA.EXE v.1.2a April 19 1991. Copyright (c) by José Campione. ║');
wrtln('║ The Inter Process Communication Area (IPCA) consists of 16 bytes at address ║');
wrtln('║ 0000h:04F0h to 0000h:04FFh. This program allows direct access of this area ║');
wrtln('║ to keep strings or byte values. These can be stored and retrieved accross ║');
wrtln('║ program, shell and subdirectory boundaries. In a way the IPCA is turned into║');
wrtln('║ a mini master environment and this program acts as a mini-SET utility... ║');
wrtln('║ COMMAND LINES: ║');
wrtln('║ ipca 0 .......... clears the IPCA. ║');
wrtln('║ ipca w .......... displays IPCA content. ║');
wrtln('║ ipca e qwerty ... enters string "qwerty" starting in position 1. ║');
wrtln('║ ipca a asdfgh ... adds "asdfgh" starting with the first available space. ║');
wrtln('║ ipca c zxcvbn ... tests for string "zxcvbn"; if found, EL=0, if not EL=1. ║');
wrtln('║ ipca r zxcvbn ... same as above but will display "yes!" or "no!". ║');
wrtln('║ ipca s 10 234 ... sets byte 10 in the ipca to the value 234. ║');
wrtln('║ ipca t 10 234 ... tests if byte 10 has value 234; if yes, EL=0, if not EL=1.║');
wrtln('║ ipca u 10 234 ... same as above but will display "yes!" or "no!". ║');
wrtln('║ ipca b 10 ....... returns value of byte 10 in errorlevel. ║');
wrtln('╚═════════════════════════════════════════════════════════════════════════════╝');
if e in [1..8] then begin
inc(textattr,128);
write('>>> Error ');
dec(textattr,128);
end;
case e of
1: wrtln('1. Two parameters required in command line.');
2: wrtln('2. 1st parameter longer than one character.');
3: wrtln('3. 2nd parameter longer than 15 characters.');
4: wrtln('4. 1st parameter not in "ABCERSTUW"');
5: wrtln('5. 2nd parameter too long to fit in IPCA.');
6: wrtln('6. 2nd parameter must be in [1..16].');
7: wrtln('7. 3rd parameter is not in [0..255].');
end;
wrtln('');
write('>>> Press any key to continue... ');
repeat until keypressed;
while keypressed do ch:= readkey;
wrtln('');
halt(255);
end;
procedure enterarr(stri: string);
var
i : byte;
begin
fillchar(ipcarr,sizeof(ipcarr),0);
for i:= 1 to ord(stri[0]) + 1 do begin
ipcarr[i]:= ord(stri[i-1]);
end;
halt(0);
end;
procedure setbyte(str1, str2: string);
var
i,v : integer;
c : integer;
begin
val(str1,i,c);
if (c <> 0) or (i < 1) or (i > 16) then error(6);
val(str2,v,c);
if (c <> 0) or (v < 0) or (v > 255) then error(7);
ipcarr[i]:= v;
halt(0);
end;
procedure retbyte(str1: string);
var
i : integer;
c : integer;
begin
val(str1,i,c);
if (c <> 0) or (i < 1) or (i > 16) then error(6);
halt(ipcarr[i]);
end;
procedure testbyte(str1, str2: string; flag: boolean);
var
i,v : byte;
c : integer;
begin
val(str1,i,c);
if (c <> 0) or (i < 1) or (i > 16) then error(6);
val(str2,v,c);
if (c <> 0) or (v < 0) or (v > 255) then error(7);
if ipcarr[i] = v then begin
if flag then wrtln('yes!');
halt(0);
end else begin
if flag then wrtln('no!');
halt(1);
end;
end;
procedure addarr(stri: string);
var
i : byte;
begin
if ipcarr[1] + ord(stri[0]) > 15 then error(5);
for i:= 1 to ord(stri[0]) do begin
ipcarr[i + ipcarr[1] + 1]:= ord(stri[i]);
end;
ipcarr[1]:= ipcarr[1] + ord(stri[0]);
halt(0);
end;
procedure comparr(stri: string; flag: boolean);
var
i : byte;
stry : string;
begin
for i:= 1 to ipcarr[1] do begin
stry[i]:= char(ipcarr[i + 1]);
end;
stry[0]:= char(ipcarr[1]);
if pos(stri,stry) > 0 then begin
if flag then wrtln('yes!');
halt(0);
end else begin
if flag then wrtln('no!');
halt(1);
end;
end;
procedure writearr;
var
i : byte;
begin
for i:= 1 to 16 do begin
case ipcarr[i] of
0 : write('_');
7 : write('.');
else write(char(ipcarr[i]));
end;
end;
writeln('[',ipcarr[1],']');
end;
begin
str1:= paramstr(1);
if (ord(str1[0]) = 1) and (upcase(str1[1]) = 'W') then begin
writearr;
halt(0);
end;
if (ord(str1[0]) = 1) and (str1[1] = '0') then begin
fillchar(ipcarr,sizeof(ipcarr),0);
halt(0);
end;
if str1 = '' then error(0);
if paramcount < 2 then error(1);
str1:= paramstr(1);
if ord(str1[0]) <> 1 then error(2);
str2:= paramstr(2);
if ord(str2[0]) > 15 then error(3);
str3:= paramstr(3);
case upcase(str1[1]) of
'A' : addarr(str2);
'B' : retbyte(str2);
'E' : enterarr(str2);
'C' : comparr(str2,false);
'R' : comparr(str2,true);
'S' : setbyte(str2,str3);
'T' : testbyte(str2,str3,false);
'U' : testbyte(str2,str3,true);
else error(4);
end;
end.